home *** CD-ROM | disk | FTP | other *** search
/ .net 2002 March / DotNetMagazine-Issue107-Coverdisc-NET107-02-03-PCMac.bin / pc / PC Software / analog / analog_530w32.exe / analog 5.30 / anlgform.pl < prev    next >
Encoding:
Perl Script  |  2002-11-30  |  7.9 KB  |  222 lines
  1. #!/usr/bin/perl
  2. ###
  3. ###              analog 5.30             http://www.analog.cx/
  4. ### This program is copyright (c) Stephen R. E. Turner 1995 - 2002 except as
  5. ### stated otherwise. Distribution, usage and modification of this program is
  6. ### subject to the conditions of the Licence which you should have received
  7. ### with it. This program comes with no warranty, expressed or implied.
  8. ### Remember: Even the most carefully-designed CGI programs can accidentally
  9. ### have serious security bugs! See docs/form.html for notes on security
  10. ### design.
  11. ###
  12. ### anlgform.pl; the cgi front end for analog
  13.  
  14. # 1) uncomment (remove everything before $analog) and edit one of the next two
  15. #    lines to give the location (full pathname) of the analog executable.
  16. #       Unix: $analog = '/usr/local/etc/httpd/analog-5.30/analog';
  17. #       Windows: $analog = 'C:\program files\analog 5.30\analog.exe';
  18. # 2) If you're on Unix, edit the first line in this file to give the location
  19. #    of Perl (don't remove the #! though).
  20. # 3) You also need to edit anlgform.html if you want to use the form.
  21. # 4) Add to the forbidden commands below if you want.
  22.  
  23. @forbidden = qw(LOGFORMAT APACHELOGFORMAT DEFAULTLOGFORMAT
  24.         APACHEDEFAULTLOGFORMAT HEADERFILE FOOTERFILE UNCOMPRESS
  25.         OUTFILE CACHEOUTFILE LOCALCHARTDIR ERRFILE DNS CGI
  26.         SETTINGS PROGRESSFREQ LANGFILE DESCFILE);
  27. # Forbidden commands: sysadmin can add more (must be in upper case!)
  28. # Other commands you might consider adding, because they allow users to
  29. # specify which files to use for the analysis, are LOGFILE and DOMAINSFILE.
  30. # If you add a command, you must also add any aliases it possesses.
  31. # There is a discussion of all this in docs/form.html.
  32.  
  33. @allowed = qw();
  34. # Allowed commands. If there are _any_ commands listed here, then _only_
  35. # commands which are in @allowed, and not in @forbidden, can be used.
  36.  
  37. require 5.001;
  38. use CGI;
  39.  
  40. # 1) INITIALISATION
  41. # delete all dangerous environment variables
  42. $ENV{PATH} = '';  # blank, not deleted, so that UNCOMPRESS doesn't get a path
  43. delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
  44. $query = new CGI;
  45. $|=1;
  46. $lt = localtime;
  47. $progname = $0 || 'anlgform.pl';
  48. if (($^O =~ /win32/i || $^O =~ /^win/i) && Win32::GetShortPathName($analog)) {
  49.     $analog = Win32::GetShortPathName($analog);
  50. }
  51.  
  52. # coerce query keys to caps in a new (key, pointer to array) hash called args
  53. # also remember the order the keys arrived in, as far as possible
  54. foreach $p ($query->param) {
  55.     foreach $a ($query->param($p)) {
  56.     checkchars($a);
  57.     push(@order, "\U$p") unless ($args{"\U$p"});
  58.     push(@{$args{"\U$p"}}, $a);
  59.     }
  60. }
  61.  
  62. # check LOGFILE and CACHEFILE only contain safe chars (see comments below)
  63. checkfilechars("LOGFILE");
  64. checkfilechars("CACHEFILE");
  65.  
  66. # 2) OPEN THE ANALOG PROCESS
  67. # qv=1 causes args to go straight to stdout, not program
  68. if (${$args{'QV'}}[-1] && !forbidden('QV')) {
  69.     print "Content-Type: text/plain\n\n";
  70.     open(ANALOG, ">-");
  71. }
  72. elsif (!$analog) {
  73.     badreq(500, "Program Incorrectly Configured",
  74.        "Can't run analog because anlgform.pl not set up properly.\n",
  75.        "See the server's error log for more details.");
  76.     print STDERR "[$lt] $progname: Can't run analog because the variable \$analog was not set: read the setup instructions!\n";
  77.     die;
  78. }
  79. elsif (!(-x $analog)) {
  80.     badreq(500, "Program Incorrectly Configured", "Can't run analog.",
  81.        "See the server's error log for more details.");
  82.     print STDERR "[$lt] $progname: Can't run analog because \"$analog\" not found or not executable";
  83.     print STDERR ": $!" if ($!);
  84.     print STDERR ".\n";
  85.     die;
  86. }
  87. else {
  88.     open (ANALOG, "|$analog +g-");  # errors here will get caught on close
  89. }
  90.  
  91. # 3) PRINT ALL THE COMMANDS
  92. # Special cases: must come first
  93. printargs('CG', 'CONFIGFILE') unless forbidden('CG');
  94. # both 'CG' and 'CONFIGFILE' must be allowed for this to happen.
  95. print ANALOG "CGI ON\nDNS NONE\nWARNINGS FL\n";
  96. printargs('WARNINGS');
  97. printargs('LOGTIMEOFFSET');
  98. foreach $k (@order) {
  99.     printargs($k)
  100.         unless($k eq 'QV' || $k eq 'CG' || $k eq 'CM' || $k =~ /FLOORB$/ ||
  101.            $k =~ /2$/ || $k =~ '^LOGTIMEOFFSET' || $k =~ '^WARNINGS' ||
  102.                # commands dealt with elsewhere
  103.                $k =~ /[^A-Z12]/ || $k eq '' || $k =~ /^IGNORE/);
  104.                # other stuff not wanted
  105. }
  106. # Special cases: must come last
  107. print ANALOG "DEBUG -C\n";
  108. printargs('CM', 'CONFIGFILE') unless forbidden('CM');
  109. # again, both 'CM' and 'CONFIGFILE' must be allowed for this to happen.
  110. print ANALOG "OUTFILE stdout\n";
  111.  
  112. # 4) WAIT FOR PROCESS TO FINISH. THAT'S IT.
  113. unless (close(ANALOG)) {
  114.     badreq(500, "Program Failure", 
  115.        "Analog failed to run or returned an error code.",
  116.        "Maybe your server's error log will give a clue why.");
  117.     print STDERR "[$lt] $progname: \"$analog\" failed to run or returned an error code";
  118.     print STDERR ": $!" if ($!);
  119.     print STDERR ".\n";
  120.     die;
  121. }
  122.  
  123.  
  124. ### SUBROUTINES 
  125. # A) IS A GIVEN COMMAND FORBIDDEN?
  126. sub forbidden {
  127.     return (grep($_[0] eq $_, @forbidden) ||
  128.         (@allowed && !grep($_[0] eq $_, @allowed)));
  129. }
  130.  
  131. # B) PRINT ONE COMMAND
  132. sub printargs {
  133.     my($is_floora) = 0;
  134.     my($is_12) = 0;
  135.     my($name) = $_[1] || $_[0];
  136.     if ($name =~ /FLOORA$/) {
  137.     chop($name);
  138.     $is_floora = 1;
  139.     }
  140.     elsif ($name =~ /1$/) {
  141.     chop($name);
  142.     $is_12 = 1;
  143.     }
  144.     return if forbidden($name);
  145.  
  146.     if ($is_floora) {
  147.     $a = ${$args{$name . 'A'}}[-1];  # last "FLOORA=$a" form arg specified
  148.     $b = ${$args{$name . 'B'}}[-1];
  149.     print ANALOG ("$name $a$b\n") if ($b ne '' && $b !~ /\\$/);
  150.     # could bracket $a$b, but no help because any special character in a
  151.     # FLOOR command is junk anyway.
  152.     }
  153.     elsif ($is_12) {
  154.     $a = ${$args{$name . '1'}}[-1];
  155.     $b = ${$args{$name . '2'}}[-1];
  156.     print ANALOG ("$name ", bracket($a), " ", bracket($b), "\n")
  157.         if ($b ne '');
  158.     }
  159.     else {
  160.     foreach $a (@{$args{$_[0]}}) {  # run through all "NAME=$a" form args
  161.         if ($a ne '') {
  162.         print ANALOG ("$name ", bracket($a), "\n");
  163.         print ANALOG ("DNS READ\n") if ($name eq 'DNSFILE');
  164.         }
  165.     }
  166.     }
  167. }
  168.  
  169. # C) PUT APPROPRIATE DELIMITERS ROUND AN ARGUMENT CONTAINING SPACES
  170. sub bracket {
  171.     local $_ = $_[0];
  172.     return $_ unless (/[\s\#]/ || /^['"\(]/ || /\\$/);
  173.     return "\"$_\"" unless (/"/);
  174.     return "'$_'" unless (/'/);
  175.     return "($_)";
  176.     # analog has no syntax if string contains ) as well as space, ' and "
  177. }
  178.  
  179. # D) CHECK ONLY SAFE CHARACTERS in LOGFILEs and CACHEFILEs. See docs/form.html.
  180. sub checkfilechars {
  181.     local ($_);
  182.     foreach (@{$args{$_[0]}}, @{$args{$_[0] . '1'}}) {
  183.     if (m([^\w\. /\\:\-\*\?]) || m(\B-|-\B)) {
  184.         # i.e. contains a non-approved character, or a dash not
  185.         # between \w's. NB \w includes underscore.
  186.         badreq(403, "Illegal Request", "Unsafe characters in $_[0].");
  187.         printf STDERR "[$lt] $progname: Unsafe characters in \"$_[0] $_\" on request from %s\n", $ENV{REMOTE_HOST}?$ENV{REMOTE_HOST}:($ENV{REMOTE_ADDR}?$ENV{REMOTE_ADDR}:"unknown host");
  188.         die;
  189.     }
  190.     }
  191. }
  192.  
  193. # E) CHECK NO UNSAFE CHARACTERS IN OTHER COMMANDS. Again, see docs/form.html.
  194. sub checkchars {
  195.     local $_ = $_[0];
  196.     if (/[\x00-\x1F\x7F-\x9F]/) {
  197.     printf STDERR "[$lt] $progname: Unsafe characters in \"\U$p\E $_\" on request from %s\n", $ENV{REMOTE_HOST}?$ENV{REMOTE_HOST}:($ENV{REMOTE_ADDR}?$ENV{REMOTE_ADDR}:"unknown host");
  198.     # Translate dangerous characters to avoid cross-site scripting
  199.     $p =~ s/&/&/;
  200.     $p =~ s/</</;
  201.     $p =~ s/>/>/;
  202.     $p =~ s/"/"/;
  203.     badreq(403, "Illegal Request", "Unsafe characters in \U$p.");
  204.     die;
  205.     }
  206. }
  207.  
  208. # F) PRINT OUT ERROR MESSAGE
  209. sub badreq {
  210.     my($i);
  211.     print "Content-Type: text/html\n";
  212.     print "Status: $_[0] $_[1]\n\n";
  213.     print '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">';
  214.     print "\n<html><head><title>$_[0] $_[1]</title></head>\n";
  215.     print "<body><h1>$_[1]</h1>\n";
  216.     for ($i = 2; defined($_[$i]); $i++) {
  217.     print "<br>" if ($i >= 3);
  218.     print "$_[$i]\n";
  219.     }
  220.     print "</body></html>\n";
  221. }
  222.